home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / PRETTY.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  13.4 KB  |  546 lines
  1. ; PRETTY.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Pretty Printer                    *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: David Bartley        Date: Jul 1984            *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. (define pp                        ; PP
  23.   (lambda (exp . args)
  24.     (let ((port (car args))
  25.       (margin (or (cadr args) 72)))
  26.       (fluid-let
  27.           ((output-port
  28.         (cond ((null? port) (fluid output-port))
  29.           ((port? port) port)
  30.           ((string? port)
  31.            (let ((p (open-output-file port)))
  32.              (set-line-length! (max margin (line-length p)) p)
  33.              p))
  34.           (else 'CONSOLE))))
  35.      (%pretty-printer exp
  36.               (min margin (line-length (fluid output-port))))
  37.      (when (string? port)
  38.            (close-output-port (fluid output-port)))
  39.      *the-non-printing-object*))))
  40.  
  41.  
  42. (define %pp-me                         ; %PP-ME
  43.   (lambda (e)
  44.     (let ((m (and (pair? e)
  45.           (getprop (car e) 'PCS*MACRO))))
  46.       (cond ((null? m)
  47.          e)
  48.         ((pair? m)            ; alias
  49.          (cons (cdr m)(cdr e)))
  50.         (else            ; macro
  51.          (pp (m e)))))))
  52.  
  53.  
  54. (syntax (%pp-set-pattern id pat)            ; %PP-SET-PATTERN
  55.     (PUTPROP id pat '%PRETTY-PRINTER-PATTERN))
  56.  
  57.  
  58. (syntax (%pp-get-pattern id)                ; %PP-GET-PATTERN
  59.     (GETPROP id '%PRETTY-PRINTER-PATTERN))
  60.  
  61.  
  62. ;
  63. ;  Pretty Printer Pattern Definitions
  64. ;
  65.  
  66. (begin
  67.   (let ((pattern '(KEY . (2 . V-TAIL))))        ; BEGIN style
  68.     (%pp-set-pattern  'BEGIN         pattern)
  69.     (%pp-set-pattern  'BEGIN0        pattern)
  70.     (%pp-set-pattern  'SEQUENCE      pattern))
  71.  
  72.   (let ((pattern '(NEAT (() . EXP) . (2 . V-TAIL))))    ; DEFINE style
  73.     (%pp-set-pattern  'ALIAS         pattern)
  74.     (%pp-set-pattern  'ACCESS        pattern)
  75.     (%pp-set-pattern  'APPLY-IF      pattern)
  76.     (%pp-set-pattern  'DEFINE        pattern)
  77.     (%pp-set-pattern  'DEFINE-INTEGRABLE
  78.                      pattern)
  79.     (%pp-set-pattern  'MACRO         pattern)
  80.     (%pp-set-pattern  'REC           pattern)
  81.     (%pp-set-pattern  'SET-FLUID!    pattern)
  82.     (%pp-set-pattern  'SYNTAX        pattern))
  83.  
  84.   (let ((pattern '(KEY (() . BVL) . (2 . V-TAIL))))    ; LAMBDA style
  85.     (%pp-set-pattern  'LAMBDA        pattern)
  86.     (%pp-set-pattern  'FLUID-LAMBDA  pattern)
  87.     (%pp-set-pattern  'NAMED-LAMBDA  pattern))
  88.  
  89.   (let ((pattern '(KEY (3 . TUPLES) . (2 . V-TAIL))))    ; LETREC style
  90.     (%pp-set-pattern  'LETREC        pattern))
  91.  
  92.   (let ((pattern '(0 . LET)))                ; LET style
  93.     (%pp-set-pattern  'LET           pattern)
  94.     (%pp-set-pattern  'LET*          pattern)
  95.     (%pp-set-pattern  'FLUID-LET     pattern))
  96.  
  97. ;(let ((pattern '(NEAT . (() . V-TAIL))))        ; SET! style
  98. ;  (%pp-set-pattern  'SET!          pattern)
  99. ;  (%pp-set-pattern  'IF            pattern)    ; use default (0 . call)
  100. ;  (%pp-set-pattern  'WHEN          pattern)    ; for these short names
  101. ;  (%pp-set-pattern  'AND           pattern)
  102. ;  (%pp-set-pattern  'OR            pattern))
  103.  
  104.   (%pp-set-pattern  'COND            '(KEY . (() . COND-TAIL)))
  105.  
  106.   (%pp-set-pattern  'CASE            '(KEY (() . EXP) . (2 . CASE-TAIL)))
  107.  
  108.   (%pp-set-pattern  'DO              '(KEY (() . TUPLES)
  109.                       (4 . COMB)
  110.                       . (2 . V-TAIL)))
  111.  
  112.   (%pp-set-pattern  '%PP-FUN-CALL    '(0 . CALL))   ; arbitrary function calls
  113.  
  114.   (%pp-set-pattern  '%PP-COMBINATION '(0 . COMB))   ; arbitrary combinations
  115.   '())
  116.  
  117. ; --------------------------------------------------------------------------
  118.  
  119. (define %pretty-printer
  120.   (lambda (expression margin)
  121.     (letrec
  122.  
  123. ;-------!
  124.  
  125.  ((cp         margin)    ; current position
  126.  
  127.   (miser-cp  (max 20 (quotient margin 2)))
  128.  
  129.   (nice-fit  (max 50 (quotient margin 2)))
  130.  
  131.   (call-pat  (%pp-get-pattern '%PP-FUN-CALL))
  132.  
  133.   (comb-pat  (%pp-get-pattern '%PP-COMBINATION))
  134.  
  135.   ;
  136.   ; PP-EXP pretty-prints expression X at the current position
  137.   ;
  138.  
  139.   (pp-exp
  140.    (lambda (x)
  141.      (cond ((atom? x)              ; X = atom ?
  142.         (pp-atom x))
  143.  
  144.        ((atom? (cdr x))          ; X = (atom) or (atom . atom) ?
  145.         (pp-block x cp))
  146.  
  147.        ((pair? (car x))          ; X = ((...)...) ?
  148.         (pp-by-pattern x cp comb-pat))
  149.  
  150.        ((and (null? (cddr x))      ; X = (quote ...)
  151.          (memq (car x) '(QUOTE
  152.                  QUASIQUOTE
  153.                  %QQ-C %QQ-CA %QQ-CD)))
  154.         (pp-block x cp))
  155.  
  156.        ((and (pair? (cddr x))      ; X = (... . ,value)
  157.          (null? (cdddr x))
  158.          (eq? (cadr x) '%QQ-C))
  159.         (pp-block x cp))
  160.  
  161.        ((symbol? (car x))          ; X = (symbol . args) ?
  162.         (pp-by-pattern x cp
  163.         (or (%pp-get-pattern (car x))
  164.             call-pat)))
  165.  
  166.        (else
  167.         (pp-block x cp)))))          ; X = (?)
  168.  
  169.  
  170.   ; PP-BY-PATTERN pretty-prints expression X at the current position
  171.   ;   (passed in IP) using the pattern PAT
  172.   ;
  173.   ; Assumptions:
  174.   ;   PAT is a valid pattern
  175.   ;   X is a pair and (cdr X) is a pair
  176.   ;   (car X) is an atom
  177.   ;   X might not be properly structured according to PAT
  178.  
  179.   (pp-by-pattern
  180.    (lambda (x ip pat)              ; ip = new base for -tabs
  181.      (cond
  182.     ((number? (car pat))          ; PAT = (tab . fun) ?
  183.      (move (- ip (car pat)))
  184.      (pp-by-function x (cdr pat)))
  185.  
  186.     ((null? (car pat))          ; PAT = (() . fun) ?
  187.      (move (- cp 1))
  188.      (pp-by-function x (cdr pat)))
  189.  
  190.     ((and (eq? (car pat) 'NEAT)
  191.           (all-fits-nicely? x))      ; X fits neatly on this line?
  192.      (pp-block x cp))
  193.  
  194.    ;    ((and (eq? (car pat) 'ALL)
  195.    ;          (all-fits? x))          ; X fits on this line?
  196.    ;     (pp-block x cp))
  197.  
  198.     (else                  ; PAT = (KEY ...)
  199.      (prin-op x)              ; emit paren and keyword
  200.      (pp-by-pat-tail (cdr x)
  201.              ip          ; emit the rest of X
  202.              (cdr pat)))
  203.     )))
  204.  
  205.   (pp-by-pat-tail
  206.    (lambda (x ip pat)
  207.      (cond ((or (atom? x)          ; X and PAT out of synch?
  208.         (null? pat))
  209.         (pp-v-tail x))          ; yes, use the default method
  210.        ((eq? (car x) '%QQ-C)
  211.         (pp-block-tail x ip))
  212.        (else
  213.         (let ((pat1 (car pat))
  214.           (pat* (cdr pat)))
  215.           (if (atom? pat1)
  216.           (begin          ; PAT matches the tail
  217.             (move (if (null? pat1)
  218.                   (- cp 1)         ; PAT = (() . fun)
  219.                   (- ip pat1)))  ; PAT = (num . fun)
  220.             (pp-by-function x pat*))
  221.           (let ((tab1 (car pat1))
  222.             (fun1 (cdr pat1)))
  223.             (move (if (null? tab1)
  224.                   (- cp 1)         ; PAT = ((() . fun) ...)
  225.                   (- ip tab1)))  ; PAT = ((num . fun)...)
  226.             (pp-by-function
  227.                 (car x) fun1)      ; pp the car
  228.             (pp-by-pat-tail      ; pp the cdr
  229.                 (cdr x) ip pat*))))))))
  230.  
  231.   (pp-by-function
  232.    (lambda (x fun)
  233.      (if (null? fun)
  234.      (pp-call x)
  235.      (case fun
  236.         (exp     (pp-exp x))
  237.         (v-tail     (pp-v-tail x))
  238.         (call     (pp-call x))
  239.         (bvl     (pp-block x cp))
  240.         (tuples     (pp-tuples x))
  241.         (let     (pp-let x))
  242.         (cond-tail     (pp-cond-tail x))
  243.         (case-tail     (pp-case-tail x))
  244.         (comb     (pp-comb x))
  245.         (else     (pp-call x))))))
  246.  
  247.   (pp-let
  248.    (lambda (x)
  249.      (if (atom? x)
  250.      (pp-atom x)
  251.      (let ((p cp))
  252.        (prin-op x)
  253.        (move (- cp 1))
  254.        (when (and (cadr x)            ; named LET ?
  255.               (atom? (cadr x)))
  256.          (set! x (cdr x))
  257.          (pp-atom (car x))        ; name
  258.          (move (- p 5)))
  259.        (if (pair? (cdr x))
  260.            (begin
  261.          (pp-tuples (cadr x))         ; pairs
  262.          (move (- p 2))
  263.          (pp-v-tail (cddr x)))        ; body
  264.            (pp-atomic-tail (cdr x)))))))
  265.  
  266.   (pp-call
  267.    (lambda (x)
  268.      (cond ((or (atom? x)
  269.         (null? (cdr x))          ; no arguments
  270.         (all-fits-nicely? x))
  271.         (pp-block x cp))
  272.        ((and (symbol? (car x))
  273.          ( < (print-length (car x)) 5))
  274.         (pp-hang x))
  275.        (else
  276.         (let ((p cp))
  277.           (prin-op x)
  278.           (move (- p 3))
  279.           (pp-v-tail (cdr x)))))))
  280.  
  281.   (pp-comb
  282.    (lambda (x)
  283.      (cond ((or (atom? x)
  284.         (and (pair? (cdr x))      ; length = 2 ?
  285.              (null? (cddr x))
  286.              (all-fits-nicely? x)))
  287.         (pp-block x cp))
  288.        ((and (symbol? (car x))
  289.          ( < (print-length (car x)) 5))
  290.         (pp-hang x))
  291.        (else
  292.         (pp-v x)))))
  293.  
  294.   (pp-case-tail
  295.    (lambda (x)
  296.      (if (atom? x)
  297.      (pp-atomic-tail x)
  298.      (let ((p cp)
  299.            (next (car x))
  300.            (rest (cdr x)))
  301.        (pp-case-item next)
  302.        (if (null? rest)
  303.            (pp-atomic-tail rest)
  304.            (begin
  305.           (move p)
  306.           (pp-case-tail rest)))))))
  307.  
  308.   (pp-case-item
  309.    (lambda (x)
  310.      (cond ((atom? x)
  311.         (pp-atom x))
  312.        ((all-fits-nicely? x)
  313.         (pp-block x cp))
  314.        (else
  315.         (display "(")
  316.         (set! cp (- cp 1))
  317.         (let ((p cp))
  318.           (pp-block (car x) cp)
  319.           (move p)
  320.           (pp-v-tail (cdr x)))))))
  321.  
  322.   (pp-cond-tail
  323.    (lambda (x)
  324.      (if (atom? x)
  325.      (pp-atomic-tail x)
  326.      (let ((p cp)
  327.            (next (car x))
  328.            (rest (cdr x)))
  329.        (pp-comb next)
  330.        (if (null? rest)
  331.            (pp-atomic-tail rest)
  332.            (begin
  333.           (move p)
  334.           (pp-cond-tail rest)))))))
  335.  
  336.   (pp-tuples
  337.    (lambda (x)
  338.      (if (and x (atom? x))
  339.      (pp-atom x)
  340.      (begin
  341.         (display "(")
  342.         (set! cp (- cp 1))
  343.         (pp-tuples-tail x)))))
  344.  
  345.   (pp-tuples-tail
  346.    (lambda (x)
  347.      (if (atom? x)
  348.      (pp-atomic-tail x)
  349.      (let ((p cp)
  350.            (next (car x))
  351.            (rest (cdr x)))
  352.        (if (or (atom? next)
  353.            (all-fits-nicely? next))
  354.            (pp-block next cp)
  355.            (pp-comb next))
  356.        (if (null? rest)
  357.            (pp-atomic-tail rest)
  358.            (begin
  359.           (move p)
  360.           (pp-tuples-tail rest)))))))
  361.  
  362.   (pp-hang
  363.    (lambda (x)
  364.      (if (atom? x)
  365.      (pp-atom x)
  366.      (begin
  367.         (prin-op x)
  368.         (move (- cp 1))
  369.         (pp-v-tail (cdr x))))))
  370.  
  371.   (pp-v
  372.    (lambda (x)
  373.      (if (and x (atom? x))
  374.      (pp-atom x)
  375.      (begin
  376.         (display "(")
  377.         (set! cp (- cp 1))
  378.         (pp-v-tail x)))))
  379.  
  380.   (pp-v-tail
  381.    (lambda (x)
  382.      (cond ((atom? x)
  383.         (pp-atomic-tail x))
  384.        ((eq? (car x) '%QQ-C)
  385.         (pp-block-tail x cp))
  386.        (else
  387.         (let ((p cp)
  388.           (next (car x))
  389.           (rest (cdr x)))
  390.           (pp-exp next)
  391.           (if (null? rest)
  392.           (pp-atomic-tail rest)
  393.           (begin
  394.             (move p)
  395.             (pp-v-tail rest))))))))
  396.  
  397.   (pp-block
  398.    (lambda (x ip)
  399.      (if (atom? x)
  400.      (pp-atom x)
  401.      (let ((quasi (assq (car x)
  402.                 '((QUOTE . "'")
  403.                   (QUASIQUOTE . "`")
  404.                   (%QQ-C . ",")
  405.                   (%QQ-CA . ",@")
  406.                   (%QQ-CD . ",.")))))
  407.        (cond ((and quasi
  408.                (pair? (cdr x))
  409.                (null? (cddr x)))
  410.           (let* ((prefix (cdr quasi))
  411.              (len (string-length prefix)))
  412.             (display prefix)
  413.             (set! cp (- cp len))
  414.             (pp-block (cadr x) (- ip len))))
  415.          (else
  416.           (display "(")
  417.           (set! cp (- cp 1))
  418.           (pp-block-tail x (- ip 1))) )))))
  419.  
  420.   (pp-block-tail
  421.    (lambda (x ip)
  422.      (cond ((atom? x)
  423.         (pp-atomic-tail x))
  424.        ((and (eq? (car x) '%QQ-C)
  425.          (pair? (cdr x))
  426.          (null? (cddr x)))
  427.         (display " . ,")
  428.         (set! cp (- cp 4))
  429.         (pp-block (cadr x)(- ip 4))
  430.         (display ")")
  431.         (set! cp (- cp 1)))
  432.        (else
  433.         (let* ((carx (car x))
  434.            (fits (all-fits? carx)))
  435.           (cond ((and (not fits)
  436.               (> ip cp))
  437.              (move ip)
  438.              (pp-block-tail x ip))
  439.             (else
  440.              (if fits            ; print the CAR
  441.              (pp-block carx ip)
  442.              (begin
  443.                (pp-exp carx)
  444.                (move ip)))
  445.              (if (atom? (cdr x))    ; print the CDR
  446.              (pp-atomic-tail (cdr x))
  447.              (begin
  448.                (move (- cp 1))
  449.                (pp-block-tail (cdr x) ip))))))))))
  450.  
  451.   (pp-atom
  452.    (lambda (x)
  453.      (write x)
  454.      (set! cp (- margin
  455.          (- (current-column) 1)))))
  456.  
  457.   (pp-atomic-tail
  458.    (lambda (x)
  459.      (cond ((null? x)
  460.         (display ")")
  461.         (set! cp (- cp 1)))
  462.        (else
  463.         (display " . ")
  464.         (set! cp (- cp 3))
  465.         (pp-atom x)
  466.         (display ")")
  467.         (set! cp (- cp 1))))))
  468.  
  469.   (prin-op
  470.    (lambda (x)
  471.      (let ((op (car x))
  472.        (p  cp))
  473.        (display "(")
  474.        (set! cp (- cp 1))
  475.        (pp-block op cp)
  476.     ; (when ( < cp miser-cp)         ; causes a bug??
  477.     ;         (move (- p 2)))
  478.        )))
  479.  
  480.   (move
  481.    (lambda (p)
  482.      (when ( < cp p)
  483.        (newline)             ; move left
  484.        (set! cp margin))
  485.      (when ( >    cp p)
  486.        (let ((cp4 (- cp 4)))     ; move right
  487.          (if ( >= cp4 p)
  488.          (begin
  489.             (display "    ")
  490.             (set! cp cp4))
  491.          (begin
  492.             (display " ")
  493.             (set! cp (- cp 1)))))
  494.        (move p))))
  495.  
  496.   (all-fits?
  497.    (lambda (x)
  498.      (fits-in? x cp 0)))
  499.  
  500.   (all-fits-nicely?
  501.    (lambda (x)
  502.      (fits-in? x (min cp nice-fit) 0)))
  503.  
  504.   (fits-in?                ; returns length[X] if <= SIZE
  505.    (lambda (x space acc)        ; returns #F otherwise
  506.      (cond ((pair? x)
  507.         (fits-in-tail? x space acc))
  508.        ((or (symbol? x) (number? x) (string? x)
  509.         (char? x) (null? x))
  510.         (let ((len (print-length x)))             ; broken
  511.           (and ( >= space len)
  512.            (+ acc len))))
  513.        (else #F))))
  514.  
  515.   (fits-in-tail?
  516.    (lambda (x space acc)
  517.      (cond ((null? acc)   #F)
  518.        (( < space 2)  #F)
  519.        ((null? x)      (+ acc 1))
  520.        ((atom? x)      (fits-in? x (- space 4)(+ acc 4)))
  521.        (else
  522.         (let ((len (fits-in? (car x) space 0)))
  523.           (and len
  524.            (fits-in-tail? (cdr x)
  525.                   (- (- space len) 1)
  526.                   (+ (+ acc len) 1))))))))
  527.  
  528.   (make-printable
  529.    (lambda (obj)
  530.      (cond ((closure? obj)
  531.         (apply-if (assq 'SOURCE (%reify obj 0))
  532.         (lambda (entry)
  533.           (display obj)
  534.           (display " =")
  535.           (newline)
  536.           (cdr entry))
  537.         obj))
  538.        ; other special cases ...
  539.        (else obj))))
  540.  
  541. ;-------!
  542.     )
  543.        (begin
  544.      (pp-exp (make-printable expression))
  545.      *the-non-printing-object*))))
  546.